BMUG PD-ROM 1995 Fall

home *** CD-ROM | disk | FTP | other *** search

/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / Yerk 3.64 ƒ / System source / Class < prev next >

Wrap

Text File | 1993-06-07 | 17.1 KB | 600 lines | [TEXT/ttxt]

\ Class/Object general properties and compilation code \ 4/26/84 CBD Version 1.0 \ 4/26/84 CBD Speeded up ^Elem and friends \ 4/27/84 CBD Moved rect, etc. to QD file \ 5/02/84 CBD Removed IX-non-IX restriction \ 5/24/84 NDI Remove selector numbering, add objlen \ 5/26/84 CBD Took non-class stuff out \ 5/28/84 CBD Selectors defer refs to input parm objects \ 10/04/84 CBD Added class initialization, text messages \ 10/11/84 CBD objPtr and objArray support \ 10/12/84 CBD Added GET: and PUT: for arrays \ 10/18/84 CBD converted to mcfa Values \ 10/30/84 CBD propagate classInit: thru Ivar chains at create \ 11/02/84 CBD objects have executable CFA \ 11/02/84 CBD update for optimized array support in nucleus \ 11/16/84 CBD removed objArray, etc. \ 12/08/84 CBD ß1.0 version \ 12/14/84 cbd removed read:, write:, etc \ 12/15/84 cbd hashed selectors \ 12/12/85 cdn Put CR after redefined message in :M \ 8/01/86 cdn Added "Method redefined, within same class ****" message \ 12/27/89 rfl changed ?isclass to check for valid ram for @ \ 1/11/90 rfl need to change traverse or at least ?cfa in nuc to protect for valid ram \ 11/23/90 rfl Method redefined message now comes before selector for readability \ 12/17/90 rfl added class name to above \ 6/01/91 rfl ovblock modified for sys 7...heap is below 0; \ 12/12/92 rfl 32 bit hash for methods; move ?rdepth to this source \ 12/25/92 rfl changed nuc to set heapBot, heapTop in relative addr space \ 12/26/92 rfl object name not unique error gives name of object \ 5/28/93 rfl added within and used it in (@) \ 6/04/93 rfl modified (build) for source documentation (line#..) 0 value (rdepth) : +rdepth 1 -> (rdepth) ; : -rdepth 0 -> (rdepth) ; : ?Rdepth (rdepth) IF rdepth 220 > ?error 116 THEN ; : +docs true -> docs ; : -docs false -> docs ; : ^CLASS current @ pfa ; \ the following offsets refer to the ^class, or Pfa of the class. : MFA 10 + ; \ methods dictionary Latest field : IFA 14 + ; \ ivar dict Latest field : DFA 18 + ; \ Datalen , width of indexed area : SFA 22 + ; \ superclass ptr field \ Get length of object's named ivars : @DLEN cfa @ Dfa W@ ; \ ( SelPfa ^class -- m1cfa ) Find a method in a class : (FINDM) swap over mfa ((findm)) 0= IF cr msg# 108 nfa .name abort ELSE swap drop THEN ; \ ( Selhash objPfa -- objPfa m1cfa ) \ Find a method 1cfa given a selector ID : FIND-METHOD dup 0= ?error 103 swap over CFA @ (FINDM) ; \ ( objAddr -- ) Look up SelID at IP and run the method : (Defer) w@(ip) \ objPfa selID Swap Find-Method Cfa \ objAddr m0cfa execute ; \ exec the m0cfa 0 Value ^Self 0 Value ^Super \ nfa of SUPER pseudo-Ivar 0 Value newObject \ object being created 1 Value rangeCheck \ true if runtime range check desired true Value dEcho \ echo load to screen? 0 -> quitvec \ clear vectors 0 -> abortvec 0 -> objInit 'c pfind -> ufind \ ( addr -- hashVal ) hash a name into a 16-bit word : Hash { addr -- } 0 addr count + addr DO 4* Dup 65535 > IF 1+ THEN I C@ 32 - xor 65535 And LOOP ; : within { n lo hi -- b } n lo >= n hi <= and ; \ check to make sure the memory addressed is within the application heap zone : (@) ( addr -- n t or f) dup heapBot heapTop within IF @ true ELSE drop false THEN ; \ ( pfa -- pfa b ) returns true if a class - make sure pfa points within appl : ?IsClass 'CODE DoClass OVER CFA (@) IF = ELSE drop false THEN ; \ ( pfa -- pfa b ) return true if an object :f ?IsObj ?IsClass IF False ELSE Dup cfa (@) IF ?IsClass swap drop ELSE false THEN THEN ;f \ ( pfa -- pfa b ) return true if an object vector : ?IsVect dup cfa (@) IF valCode = over cfa @ vectCode = or ELSE false THEN ; \ ( pfa -- pfa b ) is ref'd word an open bracket? : ?IsParen dup nfa 1+ c@ ascii [ = ; \ ( -- ) ERROR if not compiling a new class definition : ?Class Cstate 0= ?error 115 ; \ ( classIFA -- f OR 1cfa t ) search CLASS dictionaries : ivarFind here hash swap ((findm)) ; \ ( -- f OR pfa t ) Determine if next word is an instance var : vFind bl word Cstate IF \ class compile? ^class IFA ivarFind \ search IVAR chain ELSE 0 THEN ; \ leave ff \ Key to instantiation actions \ notFnd -not previously defined \ objTyp -defined as an object \ classTyp -as a class \ vecTyp -as an object vector- ptr, array, etc \ parmTyp -as a named parm \ parenType -open paren for defer group \ ( #elems ^class OR ^class -- indlen ) : IDX-HDR DFA 2+ W@ DUP IF 2DUP W, W, * align THEN ; \ ( IVnfa -- ivlfa ) : ilfa 2+ ; \ ( ilfa -- icfa ) : ^ICLASS CFALEN + @ ; \ ( ^class -- elWidth ) return the indexed element width for class : @width dfa 2+ w@ ; \ ( infa -- icfa ) transform ivar nfa to its class field : icfa ilfa 4+ ; \ ( ivarlfa -- #els wid idxOffs tf OR ff ) \ ( ivarNfa -- IvarNfa b ) True if nfa is Super or Self : ?LastIvar Dup ^Self = Over ^Super = OR ; \ InitIvar performs the classInit: method on the ivar on the stack ) Forward InitIvar \ ( ivarNfa -- latestNfa ) -> Latest nested Ivar : ^LatestIvar ilfa ^Iclass IFA @ ; : ^NextIvar ILFA @ ; \ ( ivarnfa -- ivoffs ) Return ivar's offset : @IvarOffs ILFA 8+ W@ ; \ ( ivarNfa -- IvarNfa newNfa t OR ivarNfa f ) : ?Nest Dup ^LatestIvar ?LastIvar IF Drop 0 ELSE 1 THEN ; \ ITRAV traverses the tree of nested ivar definitions in a \ class, building necessary indexed area headers \ the Mstack has the base offset for nested Ivars \ ( ivarNfa -- ) : ITRAV BEGIN ?Rdepth ?Nest IF Over @IvarOffs Dupm Addm Itrav THEN Dup ILFA dup \ DO-NODE - Build header if indexed ivar pushm copym ^iclass -dup \ HDR-INFO IF copym $ 0a + w@ popm 8+ w@ ( #els offs ) rot dup dfa w@ rot + swap @width ( #els truoffs wdth) swap over -dup IF ELSE 2drop drop 0 THEN ELSE dropm 0 THEN \ not idx IF CopyM + \ add in nested base offset pushm copym newObject + w! ( ! el-width ) popm newObject + 2+ W! ( ! # els ) dup 4+ @ \ get ^class of indexed Ivar over 8+ w@ \ get offs this ivar copym newObject + + cfa ! \ store in cfa THEN initIvar ^NextIvar ?LastIvar Not WHILE REPEAT DROP DropM ; Forward ClassInit \ ( #elems ^class OR ^class -- ) Compile an instance variable dictionary entry : <VAR pushm \ place ^class on methods stack for later Vfind ?error 117 here dup hash w, \ compile hashed ivar name into dict ^Class IFA dup @ , ! COPYM , ( link, class ) copym @width IF 4 ^class dfa w+! THEN \ if indexed, save 4 for cfa ^Class DFA W@ W, \ ( current dLen= offset ) copym @width dup IF over * swap W, 4+ THEN ( #elems) popM DFA W@ + align \ Account for named ivar lengths ^Class DFA W+! ; \ ( -- ) Create hdr for the name at Here : CreateHdr Here 1+ c@ 0= ?error 118 $ 80 S, latest , current ! 0, ; \ ( m1cfa n -- ) Execute the ncfa of word on stack \ takes a standard Pfa = 1cfa as input \ : mExec clen * swap 4- + Execute ; \ ( #elems ^class OR ^class -- ) Build an instance of a class : (BUILD) Pushm Cstate IF Popm <Var \ build an ivar ELSE \ NEWTOKEN : pulls name from stream Here 1 and IF 0 c, THEN docs IF line# w, THEN Find IF drop ?isVect IF 3 ( vecTyp ) ELSE 1 ( objTyp ) THEN ELSE 0 ( notFnd ) THEN ( -- pfa type OR 0 ) \ OBJHDR : \ Build a public object header or just a cfa if headerless \ If an object vector, load pfa of object into vector \ ( {vectPfa} objType -- ) HERE is left at pfa of new object Select{ \ on object type 0 ( notFnd ) Is{ CreateHdr }End \ not redefined 1 ( objTyp ) Is{ drop createHdr type# 181 ( Object name not unique ) latest id. cr }End 2 ( classtyp ) Is{ abort }End \ should not get this \ ( ind vecPfa -- ) for object vectors, execute -> code at 2cfa 3 ( vecTyp ) Is{ 0, Here swap 2 clen * swap 4- + Execute msg# 120 }End Default{ abort }Select Here -> newObject Copym here cLen - ! \ store ^class copym DFA W@ ( dfa datalen ) Reserve \ allocate named instances copym IDX-HDR reserve popm IFA @ ?LastIVar not IF 0 Pushm Itrav ELSE drop THEN classInit THEN ; \ yerk grow zone function 'c null vect growZone \ ( size -- addr ) acquire a block of nonrelocatable heap : ovBlock { size -- addr } size newPtr dup +base 0= IF drop growZone size newPtr dup +base 0= ?error 121 THEN ; \ build a new object on the heap for class. Use: Heap> className \ gets heap, and returns relative ptr : (heapObj) { theClass \ dLen obAddr idWid #els -- } 0 -> #els theClass dfa w@ -> dlen theClass dfa 2+ w@ -> idWid idWid IF -> #els THEN dLen 4+ idWid IF idWid #els * 4+ + THEN \ get total length of obj ovBlock 4+ -> obAddr \ get nonReloc heap, save ptr to cfa theClass obAddr cfa ! \ create the class ptr idWid IF idWid obAddr dLen + w! #els obAddr dLen + 2+ w! THEN obAddr -> newObject theClass ifa @ ?LastIvar not IF 0 PushM Itrav ELSE Drop THEN classinit obAddr ; : heap> @pfa ?isClass not ?error 122 state IF Compile lit , Compile (heapObj) ELSE (heapObj) THEN ; Immediate \ ( -- ) Set CSTATE to compiling a class : ]C 1 -> Cstate ; Immediate : C[ 0 -> Cstate ; Immediate \ compile hashed word for name at Here : hash, @word hash w, ; $ 81FE0000 variable aName 0 W, \ fake name/link \ ( -- ) The super class of Object - top of all inheritance : Meta <[ 'Code doClass ^Class CFA ! here 10 allot 'code objmp swap 10 cmove \ jump to object code aName , \ latest method pointer 0, \ latest ivar pointer -> SUPER 0, ( data len, flags) 0, ( super pointer) HERE -> ^SELF hash, SELF \ SELF ivar 0, 0, 65535 W, ( link, ^class, offset) Here -> ^Super \ save this address for later hash, SUPER ^self , 0, 65535 W, ( link, ^class, offset ) ^super ' meta ifa ! \ ( -- ) Build a class header with its superclass pointer : <Super @pfa dup \ find the superclass dup ^Super icfa ! \ store superclass in SUPER CFA here CFA \ Set up for cmove to sub class 26 Cmove \ create image of superclass header ^Class SFA ! \ store superclass pointer ^Class ^Self icfa ! \ store ^class in SELF's icfa 26 allot [Compile] ]C [Compile] <[ \ in class, interpret ; Immediate 'c copym Vect caller \ late bound reference to calling object \ ( -- b ) true if word at Here is a selector xxx: : ?isSel here count 1- + c@ ascii : = here c@ 1 > And ; \ get a selector from the input stream : getSelect @word dup c@ 15 > ?error 123 ?isSel 0= ?error 124 hash ; \ ( -- ) Build a methods dictionary entry for selector : :M { \ selID -- } ?Class !Csp [Compile] ]> getSelect -> selID selID ^class mfa ((findm)) \ is method already defined? IF type# 182 here count type ( Method redefined ) space latest id. \ add class name ^class > IF type# 183 ( , within same class **** ) THEN cr THEN here selID w, \ name is selector's hashed value ^class mfa dup @ \ get mfa, old link , ! \ establish the links \ build methods cfas 'Code M0CFA , 'Code M1CFA , ; Immediate \ ( -- pfa tokenID ) Determine type of token referenced by selector. : refToken uFind \ look for named stack parm IF drop 4 ( parmTyp ) ELSE here latest (find) 0= ?error 125 drop ?IsClass IF 2 ( classTyp ) ELSE ?IsVect IF 3 ( vecTyp ) ELSE ?IsObj IF 1 ( objTyp ) ELSE ?IsParen IF 5 ( parenType ) ELSE 1 ?error 126 THEN THEN THEN THEN THEN ; \ ( objpfa -- a:datalen ) : ^dlen cfa @ dfa ; \ ( ivarPfa m1cfa ) compile an Ivar reference : ivar, , w@ w, ; \ | 1cfa | offs | \ ( objPfa m0cfa ) compile an object ref : obj, swap cfa , , ; \ | objCfa | m0cfa | \ ( selID ivPFa ) : ivarRef Find-Method ivar, ; \ ( selID -- ) Build a reference to an object or vector : objRef refToken SELECT{ 0 ( notFnd ) IS{ abort }END ( selID objPfa -- ) 1 ( objTyp ) IS{ cfa execute Find-Method cfa obj, }END \ normal obj ref 2 ( classTyp ) IS{ (FINDM) cfa , }END \ compile m0cfa ( selPfa vecPfa -- ) 3 ( vecTyp ) IS{ cfa , Compile (defer) w, }END 4 ( parmTyp ) IS{ cfa , \ named parm- compile the pickCfa Compile (Defer) W, }END \ auto deferred 5 ( parenType ) IS{ drop pushM 251 }END \ paren'd defer group DEFAULT{ abort }SELECT ; \ ( selPfa -- ) Execute using token in stream : runRef @Pfa drop refToken Select{ 0 ( notFnd ) Is{ abort }End 1 ( objTyp ) Is{ cfa execute Find-Method }End 2 ( classTyp ) Is{ (Findm) }End ( selID vecPfa -- ) 3 ( vecTyp ) Is{ cfa execute Find-Method }End 4 ( parmTyp ) Is{ abort }End \ open bracket denotes a deferred ref to what \ the paren'd group puts on the stack at runtime 5 ( parenType ) Is{ drop Pushm ' null }End Default{ abort }Select cfa execute ; \ execute the object, m0cfa \ ================= Selector support ========================== \ message is the message compiler invoked by using a selector : message state IF \ Compile state VFIND \ instance variable? IF ivarRef \ ivar reference ELSE objRef \ compile object/vector reference THEN ELSE runRef \ run state - execute object/vector ref THEN ; Immediate \ if parsed word is a message selector, leave cfa of message compiler \ ( -- selID msgPfa 0 t OR f ) : msgFind ?isSel IF Here hash \ leave selID ' message $ c1 true ELSE pfind \ look for named parms THEN ; 'c msgFind -> Ufind \ Force late binding of method to object, as in SmallTalk \ a close bracket pops the last selID from the methods stack and \ compiles a defer: selID. This will build a deferred reference to the \ parenthesized group. : ] State IF 251 ?Pairs Compile (Defer) mdepth 0= ?error 127 popM W, \ Compile | {defer} |SelPfa| ELSE popM Swap Find-Method Cfa \ exec state execute THEN ; Immediate \ left bracket has no meaning unless preceded by a selector. : [ true ?error 128 ; Immediate : ;M ?Csp Compile (;M) ; Immediate \ Leave class compilation state, and zero the class ptrs of Self and Super : ;Class [Compile] <[ [Compile] C[ 0 ^Super icfa ! 0 ^Self icfa ! ; Immediate : :Class [Compile] : ; Immediate \ ( width -- ) Set a class and its subclasses to indexed : <Indexed ?class ^class DFA 2+ W! ; \ ( dim -- ) Set an indexed class to a multi-dimensionality \ : <Dim \ ?class ^class DFA 2+ W@ 0= ?error 175 \ misuse of <Dim \ ^class DFA 2+ c! ; \ ( index -- addr ) ( dlen ^base -M- dlen ^base ) range check : ?Range dup 0< >R range? R> or ClassErr" 129 ; \ ( index -- addr ) Return pointer to indexed element # : ^Elem ?Class RangeCheck IF Compile ?range THEN Compile (^elem) ; Immediate \ An object's base addr is always on top of mstack Create ^base \ make code word alias 'Code copym here cfa ! \ length does not include cfa \ ( -- objlen ) compute total length of object \ - requires obj addr on mstack : objlen copym @dlen copym ^dlen 2+ w@ -dup IF idxBase 2- w@ * + 4+ THEN ; \ Define class init routine :F classInit classinit: newObject ;F \ ( ^ivarLfa -- ) ( ivarOffs -M- ) getSelect classInit: Constant initID :F initIvar initID swap 8+ \ ( selID ivPfa ) dup cfa @ \ non-0 ^class? IF Find-Method cfa swap W@ ( 0cfa ivOffs ) copym newObject + + ( 0cfa ^data ) swap execute \ execute the 0cfa ELSE 2drop \ don't try to init Self or Super THEN ;F \ clean up class compiler data on an Abort ' ;class cfa -> abortVec \ dump will be in the Util module Forward dmp \ install object builder ' (build) cfa -> bldvec \ ( -- ) error if object is not indexed : ?ixObj copym 4- @ ?IsClass not swap dfa 2+ w@ 0= or classErr" 130 ; : ?ixRange ?IxObj ?range ; 'c ?ixRange vect ?idx : +range 'c ?ixRange -> ?idx ; : -range 'c null -> ?idx ; \ no range checking :CLASS Object <Super Meta :M AT: ?idx At4 ;M ( index -- val ) :M TO: ?Idx (^elem) ! ;M ( val Index -- ) :M +TO: ?idx ++4 ;M ( incVal index -- ) :M ^ELEM: ?Idx ^elem ;M ( index -- addr ) \ Leave max #elements for array :M LIMIT: ?ixObj limit ;M ( -- limit ) \ ( e0 e1... en -- ) indexed PUT: loads array from stack :M PUT: ?ixObj limit 0 DO limit i- 1- (^elem) ! LOOP ;M \ ( -- e0 e1 ...en) Indexed GET: places elements on stack :M GET: ?ixObj limit 0 DO i at4 LOOP ;M :M CLASS: copym cfa @ ;M \ non-IX - leave class ptr \ ( -- addr len ) leave class name string for object :M WIDTH: ?ixObj idxBase 4- W@ ;M \ IX - element size for array \ ( value -- ) Fill all elements with a value :M FILL: limit 0 DO dup i to: self LOOP drop ;M \ ( -- ) Indexed Clear: erases indexed area :M CLEAR: idxBase Width: self Limit: Self * Erase ;M :M ABS: (abs) ;M \ Absolute copy of mstack :M ADDR: copym ;M \ ( -- addr ) Leave addr of 0th indexed element :M IXADDR: idxBase ;M \ ( -- len ) Return total length of object :M LENGTH: objlen ;M :M PRINT: copym objlen dmp ;M :M DUMP: print: self ;M \ alias for Print: :M CLASSINIT: ;M \ null method for object init ;CLASS \ Bytes is used as the allocation primitive for basic classes : BYTES ?Class ' Object <Var ^Class Dfa W+! ; \ define code words to get and set handle sizes \ ( handle size -- RC ) set handle size with condition code Create setHSize popD0 popA0 $ a024 w, \ call SetHandleSize pushD0 next, \ ( handle -- size ) get handle size Create getHSize popA0 $ a025 w, \ call GetHandleSize pushD0 next, <" Struct